home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #21 (Jun 87) / forth source / Permanent DA < prev   
Text File  |  1987-04-06  |  12KB  |  501 lines
  1. ( A multi-window, multi-menu, permanent desk accessory  )
  2. ( J. Langowski March 87 )
  3.  
  4. only forth also assembler also mac
  5.  
  6. INCLUDE" ::general defs"
  7.  
  8. BINARY
  9. 0000110111101010 CONSTANT DAEmask
  10.  
  11. HEX
  12. A20 CONSTANT MBarEnable
  13. A88 CONSTANT CloseOrnHook
  14.  
  15. ( *** close intercept routine *** )
  16. HEX
  17. 1B4 CONSTANT SystemTask
  18. HEADER inter.start
  19. HEADER DAName
  20.     DC.B     10,0,'Mach 2 DA'
  21. HEADER trapaddr 
  22.     DC.L    0
  23. header inter.stack 40 allot
  24. CODE setup.inter.stack
  25.     LEA -8(PC),A6   ( local stack grows downward from here )
  26.     RTS
  27. END-CODE
  28.  
  29. : inter 
  30.     call frontwindow windowkind + @
  31.     2 <> IF
  32.         ['] trapaddr @ SystemTask call SetTrapAddress
  33.         ['] DAName call OpenDeskAcc drop
  34.     THEN
  35. ;
  36.      
  37. CODE intercept
  38.     MOVEM.L    A0-A4/A6/D0-D7,-(A7)
  39.     JSR    setup.inter.stack
  40.     JSR    inter
  41.     MOVEM.L (A7)+,A0-A4/A6/D0-D7
  42.     MOVE.L    trapaddr,-(A7)
  43.     RTS
  44. END-CODE
  45. HEADER inter.end
  46. ( for exportation )
  47. ' trapaddr  ' inter.start - CONSTANT *trapaddr
  48. ' intercept ' inter.start - CONSTANT *inter
  49. DECIMAL
  50.  
  51.  
  52. ( *** start of desk accessory main code *** )
  53.  
  54. header testDA ( marker for writing to DRVR resource )
  55.     header drvrFlags  2 allot
  56.     header drvrdelay  2 allot
  57.     header drvrEMask  2 allot 
  58.     header drvrMenu   2 allot
  59.     header drvrOpen   2 allot
  60.     header drvrPrime  2 allot
  61.     header drvrCtl     2 allot
  62.     header drvrStatus    2 allot 
  63.     header drvrClose  2 allot
  64.     header drvrname  32 allot
  65.  
  66. ( *** main desk accessory routines *** )
  67. header temprect 8 allot
  68. header SizeRect 8 allot     ( grow size limits )
  69. header NewSize 4 allot        ( for SizeWindow )
  70. header penLoc 4 allot        ( pen location )
  71. header tempString 256 allot ( for numeric conversion etc. )
  72. header ButtonHdl 4 allot    ( for storage of control handle )
  73. header closeflag 4 allot    ( for storage of close status )
  74. header CurMenuList 4 allot  ( menu list temporary storage )
  75. header CloseOrn 4 allot        ( CloseOrnHook temporary storage )
  76. header window2 4 allot        ( second DA window )
  77. header showflag 4 allot     ( state of 2nd window, 1: visible, 0: not)
  78. header myRes0 4 allot        ( local res ID=0 offset )
  79. header temp 4 allot            ( general purpose )
  80.  
  81. : @mouse { | mousept -- point } 
  82.     ^ mousept call getMouse mousept ;
  83.  
  84. : cl    ( WPtr -- ) portrect + call eraserect ;
  85.  
  86. : tp  call drawstring ;
  87.  
  88. : crd ['] penLoc call getpen
  89.     10 ( horizontal boundary )
  90.     ['] penLoc w@ 12 +
  91.     call moveto
  92. ;
  93.  
  94. : realclose { | dCtlEntry }
  95.     MOVE.L A1,-(A6)
  96.     -> dCtlEntry
  97.     MOVE.L A4,-(A6)
  98.     CASE 
  99.         dCtlEntry dCtlWindow + @ OF
  100.             ['] closeflag off
  101.             dCtlEntry dCtlRefNum + w@ call CloseDeskAcc
  102.         ENDOF
  103.  
  104.         ['] window2 @ OF 5 call sysbeep ENDOF
  105.     ENDCASE
  106. ;
  107.  
  108. ( *** event-handling routines *** )
  109. : >oldMBar
  110.     ['] CurMenuList @ call SetMenuBar
  111.     call DrawMenuBar
  112.     0 MBarEnable w!
  113. ;
  114.  
  115. : activate-handler { DAWind event-rec | menuID -- }
  116.     ['] myRes0 @ -> menuID
  117.     CloseOrnHook @ ['] CloseOrn !
  118.     ['] realclose CloseOrnHook !
  119.     event-rec modifiers + w@ 1 and
  120.     IF ( window activated )
  121.         call frontwindow CASE DAWind OF    
  122.             menuID MBarEnable w!
  123.             call GetMenuBar ['] CurMenuList !
  124.             call ClearMenuBar 
  125.             menuID         call getRMenu 0 call InsertMenu
  126.             menuID 1+     call getRMenu 0 call InsertMenu
  127.             call drawMenuBar
  128.             ENDOF
  129.         ENDCASE
  130.     ELSE >oldMBar ( window deactivated )
  131.         ['] CloseOrn @ CloseOrnHook !
  132.     THEN
  133. ;
  134.  
  135.     
  136. : update-handler    { DAWind event-rec | -- }
  137.     ['] penLoc call GetPen
  138.     DAWind CALL BeginUpdate
  139.        DAWind cl
  140.        DAWind CALL DrawGrowIcon
  141.        DAWind CALL DrawControls
  142.     DAWind CALL EndUpdate
  143.     ['] penLoc 2+ w@ ['] penLoc w@ call moveto ( restore pen position )
  144. ;
  145.  
  146. : invalSize { gPort | b r -- }
  147.     gPort 4 + w@ -> b
  148.     gPort 6 + w@ -> r
  149.     ['] temprect r 16 - 0 r b call setrect
  150.     ['] temprect call invalrect
  151.     ['] temprect 0 b 16 - r b call setrect
  152.     ['] temprect call invalrect
  153. ;
  154.  
  155. : mousedn-handler 
  156.     { DCtlEntry DAWind event-rec | 
  157.         whereM DAPort whichCtl whichWind mouseloc menuID menuRes wKind -- }
  158.     ['] myRes0 @ -> menuID
  159.     DAWind portrect + -> DAPort
  160.     event-rec where + @ dup -> whereM -> mouseloc
  161.     ^ mouseloc call GlobalToLocal
  162.     whereM ^ whichWind call FindWindow drop ( result code )
  163.  
  164. whichWind CASE
  165.     DAWind OF
  166.     DAWind windowkind + dup w@ -> wKind 
  167.     8 swap w! ( set to application-created window )
  168.     whereM ^ whichWind call FindWindow 
  169.     CASE  
  170.         inGrow OF
  171.         DAPort invalSize
  172.         DAWind whereM ['] SizeRect call GrowWindow 
  173.         DAWind swap unpack swap -1 call sizewindow
  174.         DAPort invalSize
  175.         ENDOF
  176.  
  177.         inZoomIn OF 
  178.            DAWind whereM 7 call TrackBox
  179.             IF DAPort invalSize
  180.                DAWind 7 0 call ZoomWindow THEN
  181.         ENDOF
  182.  
  183.         inZoomOut OF 
  184.            DAWind whereM 8 call TrackBox
  185.             IF DAPort invalSize
  186.                DAWind 8 0 call ZoomWindow THEN
  187.         ENDOF
  188.  
  189.         mouseloc DAWind ^ whichCtl call FindControl
  190.         IF
  191.             whichCtl mouseLoc 0 call TrackControl
  192.             IF ['] window2 @ 
  193.                1 ['] showflag @ - ['] showflag !
  194.                ['] showflag @
  195.                IF call showwindow ELSE call hidewindow THEN  
  196.             THEN
  197.         ELSE
  198.         " Mouse down" tp crd
  199.         THEN
  200.         
  201.     ENDCASE
  202.     wKind DAWind windowkind + w! ( reset to DA window )
  203.  
  204.     ENDOF
  205.  
  206.     ['] window2 @ OF 5 call sysbeep ENDOF
  207.  
  208. ENDCASE
  209. ;
  210.  
  211. : update-cursor    { DAWind | -- }
  212.     @mouse DAWind portrect + call PtInRect
  213.     IF call InitCursor THEN
  214. ;
  215.  
  216. : getDrvrID { dCtlEntry | -- num }
  217.     dCtlEntry dCtlRefNum + w@ l_ext
  218.     1+ negate
  219. ;
  220.  
  221. : ownResID ( resID drvrID )
  222.     5 shl + -16384 +
  223. ;
  224.  
  225. : install.intercept { dCtlEntry | procHdl -- }
  226.     "proc ['] myRes0 @ call GetResource -> procHdl
  227.     SystemTask call GetTrapAddr
  228.     procHdl @ *trapaddr + !
  229.     procHdl @ *inter + SystemTask call SetTrapAddr 
  230. ;
  231.  
  232. : Open { DCtlEntry ParamBlockRec | DAWind DAWind2 Res0 oldPort -- }
  233.     ^ oldPort call GetPort
  234.     dCtlEntry dCtlWindow + @
  235.     0= IF ( not open already )
  236.         ['] closeflag on
  237.         ['] showflag off
  238.         0 dCtlEntry getDrvrID ownResID -> Res0
  239.         Res0 ['] myRes0 !
  240.         "proc Res0 call GetResource
  241.                 call ReleaseResource ( remove from sysheap )
  242.         Res0 dCtlEntry DCtlMenu + w! 
  243.             ( menu ref has to be updated )
  244.         Res0 0 0 call getNewWindow -> DAWind
  245.         DAWind  dCtlEntry dCtlWindow + !  ( store window pointer )
  246.         DAWind  dCtlEntry dCtlRefNum + w@  swap windowKind + w!
  247.         Res0 1+ 0 0 call getNewWindow -> DAWind2
  248.         DAWind2 ['] window2 !
  249.         DAWind2  dCtlEntry dCtlRefNum + w@  swap windowKind + w!
  250.         DAWind  call setport
  251.         ['] sizerect 50 50 500 320 call setrect
  252.         10 40   call moveto
  253.         Res0 DAWind call GetNewControl ['] ButtonHdl ! 
  254.         oldPort call setPort
  255.     THEN
  256. ;
  257.  
  258. : Close { DCtlEntry ParamBlockRec | -- }
  259.     dCtlEntry dCtlWindow + 
  260.     dup @ call DisposWindow  0 swap ! ( so that Open will work again )
  261.     ['] window2 @ call disposWindow
  262.     ['] closeflag @ IF DCtlEntry install.intercept THEN
  263.     MBarEnable w@ IF >oldMBar THEN
  264. ;
  265.  
  266. : Ctl { DCtlEntry ParamBlockRec | DAWind oldPort event-rec menuID menuRes -- }
  267.     
  268.     ^ oldPort call GetPort
  269.     dCtlEntry dCtlWindow + @ dup -> DAWind call setport
  270.     4 call textfont 9 call textsize
  271.     DCtlEntry DCtlMenu + w@ l_ext -> menuID
  272.     ParamBlockRec csCode + w@ l_ext 
  273.     CASE
  274.         goodBye    OF 10 call sysbeep
  275.                     dCtlEntry ParamBlockRec Close
  276.                     ['] closeflag off ENDOF
  277.         accEvent    OF 
  278.                 ParamBlockRec csParam + @ -> event-rec
  279.                 event-rec what + w@ 
  280.                 CASE
  281.                 mousedn-evt    OF     
  282.                     DCtlEntry DAWind event-rec mousedn-handler  ENDOF
  283.  
  284.                 keydn-evt    OF DAWind cl
  285.                         DAWind call DrawGrowIcon
  286.                         DAWind call DrawControls
  287.                         10 40 call moveto " Key down." tp crd
  288.                         ENDOF
  289.  
  290.                 autokey-evt    OF    ENDOF
  291.  
  292.                 update-evt    OF
  293.                  DAWind event-rec update-handler     ENDOF
  294.  
  295.                 disk-evt    OF    ENDOF
  296.  
  297.                 activate-evt    OF
  298.                  DAWind event-rec activate-handler  ENDOF
  299.  
  300.                 network-evt    OF    ENDOF
  301.                 driver-evt    OF    ENDOF
  302.  
  303.                 ENDCASE
  304.  
  305.                 ENDOF
  306.  
  307.         accRun    OF  ['] window2 @ dup call setport cl
  308.                     4 call textfont 9 call textsize
  309.                     20 10 call moveto
  310.                     ['] temp call readdatetime drop
  311.                     ['] temp @ -1 ['] tempstring call IUTimeString
  312.                     ['] tempstring tp  
  313.                 ENDOF
  314.         accCursor    OF    DAWind update-cursor    ENDOF
  315.         accMenu    OF
  316.             ParamBlockRec csParam + @ unpack -> menuRes
  317.             l_ext            
  318.                 CASE menuID OF
  319.                     menuRes
  320.                     CASE     1 OF " Item1-1!" tp crd ENDOF
  321.                         2 OF " Item1-2!" tp crd ENDOF
  322.                         3 OF " Item1-3!" tp crd ENDOF
  323.                         4 OF " Item1-4!" tp crd ENDOF
  324.                         6 OF " Item1-6!" tp crd ENDOF
  325.                     ENDCASE ENDOF
  326.                  menuID 1+ OF
  327.                     menuRes
  328.                     CASE     1 OF " Item2-1!" tp crd ENDOF
  329.                         2 OF " Item2-2!" tp crd ENDOF
  330.                         3 OF " Item2-3!" tp crd ENDOF
  331.                         4 OF " Item2-4!" tp crd ENDOF
  332.                         6 OF " Item2-6!" tp crd ENDOF
  333.                     ENDCASE 
  334.                 ENDOF
  335.             ENDCASE 
  336.         0 call HiLiteMenu
  337.     ENDOF 
  338.         accUndo    OF    ENDOF
  339.         accCut    OF    ENDOF
  340.         accCopy    OF    ENDOF
  341.         accPaste    OF    ENDOF
  342.         accClear    OF    ENDOF
  343.     ENDCASE
  344.     oldport call setPort
  345. ;
  346.  
  347.  
  348. : DrStatus { DCtlEntry ParamBlockRec | -- }
  349. ;
  350.  
  351. : Prime { DCtlEntry ParamBlockRec | -- }
  352. ;
  353.  
  354. ( *** glue routines *** )
  355. header local.stack 1000 allot
  356.  
  357. CODE setup.local.stack
  358.     LEA -8(PC),A6   ( local stack grows downward from here )
  359.     RTS
  360. END-CODE
  361.  
  362. CODE DAOpen 
  363.     MOVEM.L A0-A1,-(A7)
  364.     setup.local.stack
  365.     MOVE.L  A1,-(A6) 
  366.     MOVE.L  A0,-(A6)
  367.     Open
  368.     CLR.L  D0
  369.     MOVEM.L (A7)+,A0-A1 
  370. RTS END-CODE
  371.  
  372. CODE DAClose  
  373.     MOVEM.L A0-A1,-(A7)
  374.     setup.local.stack
  375.     MOVE.L  A1,-(A6) 
  376.     MOVE.L  A0,-(A6)
  377.     Close
  378.     CLR.L   D0
  379.     MOVEM.L (A7)+,A0-A1 
  380. RTS END-CODE
  381.  
  382. CODE DACtl 
  383.     MOVEM.L A0-A1,-(A7)
  384.     setup.local.stack
  385.     MOVE.L  A1,-(A6) 
  386.     MOVE.L  A0,-(A6)
  387.     Ctl
  388.     CLR.L   D0
  389.     MOVEM.L (A7)+,A0-A1
  390.     MOVE.L  JioDone,-(A7) 
  391. RTS END-CODE
  392.  
  393. CODE DAStatus 
  394.     MOVEM.L A0-A1,-(A7)
  395.     setup.local.stack
  396.     MOVE.L  A1,-(A6) 
  397.     MOVE.L  A0,-(A6)
  398.     DrStatus
  399.     CLR.L   D0
  400.     MOVEM.L (A7)+,A0-A1 
  401. RTS END-CODE
  402.  
  403. CODE DAPrime 
  404.     MOVEM.L A0-A1,-(A7)
  405.     setup.local.stack
  406.     MOVE.L  A1,-(A6) 
  407.     MOVE.L  A0,-(A6)
  408.     Prime
  409.     CLR.L   D0
  410.     MOVEM.L (A7)+,A0-A1 
  411. RTS END-CODE
  412.  
  413. header endDA ( *** code written to DRVR resource ends here *** )
  414.  
  415. ( *** initialization routines *** ) 
  416.  
  417. : setFlags  ['] drvrFlags     w! ;
  418. : setDelay     ['] drvrDelay    w! ;
  419. : setEMask     ['] drvrEMask    w! ;
  420. : setMenuID    ['] drvrMenu    w! ;
  421.  
  422. : setOpen    ['] drvrOpen    w! ;
  423. : setPrime    ['] drvrPrime    w! ;
  424. : setCtl    ['] drvrCtl        w! ;
  425. : setStatus    ['] drvrStatus    w! ;
  426. : setClose    ['] drvrClose    w! ;
  427.  
  428. : setName { addr len | target -- }
  429.     ['] drvrName -> target
  430.     len target c!
  431.     addr target 1+
  432.     len 31 > if  31 else len then
  433.     cmove
  434. ;
  435.  
  436.  
  437. ( write resource to file ) 
  438. : $create-res ( str-addr - errcode )
  439.     call CreateResFile
  440.     call ResError L_ext
  441. ;
  442.  
  443. : $open-res { addr | refNum - refNum or errcode }
  444.     addr call OpenResFile -> refNum
  445.     call ResError L_ext
  446.     ?dup IF ELSE refNum THEN
  447. ; 
  448.  
  449. : close-res ( refNum - errcode )
  450.     call CloseResFile
  451.     call ResError L_ext
  452. ;
  453.  
  454. : make-res { addr len rtype ID name | -- }
  455.     addr len call PtrToHand 
  456.     abort" Could not create resource handle"
  457.     rtype ID name call AddResource
  458. ;
  459.  
  460. : write-out { filename | refnum -- } 
  461.     filename $create-res abort" That resource file already exists"
  462.     filename $open-res
  463.     dup 0< abort" Open resource file failed"
  464.     -> refnum
  465.     refnum call UseResFile
  466.     ['] testDA ['] endDA over - 
  467.         "drvr 12 " Mach 2 DA" make-res
  468.     ['] inter.start ['] inter.end over - 
  469.         "proc -16000 " Mach 2 DA" make-res
  470.         "proc -16000 call GetResource
  471.         dup 80 call SetResAttrs  ( 64: sysheap + 16: locked )
  472.         call ChangedResource
  473.     refnum close-res abort" Could not close resource file"
  474. ;
  475.  
  476. : init-DA
  477. ( initialize offsets )
  478.     ['] DAOpen     ['] testDA -  setOpen 
  479.     ['] DAPrime  ['] testDA -  setPrime
  480.     ['] DACtl    ['] testDA -  setCtl 
  481.     ['] DAStatus ['] testDA -  setStatus
  482.     ['] DAClose  ['] testDA -  setClose
  483. ( initialize driver name )
  484.     " Mach 2 DA" count setname
  485. ( initialize driver flags, NeedLock, NeedTime, NeedGoodBye, CtlEnable )
  486.     [ hex ] 7400 setFlags [ decimal ]
  487. ( initialize delay time )
  488.     60 setDelay
  489. ( initialize event mask, events recommended in IM )
  490.     DAEMask setEMask 
  491. ( initialize menu ID, local ID=0 for DRVR ID=12 )
  492.     -16000 setMenuID ( careful! this field will NOT be changed
  493.                 by the DA Mover when ID is changed )
  494. ;
  495.     
  496. : make-DA
  497.     init-DA
  498.     " Mach2 DA.rsrc" $delete drop
  499.     " Mach2 DA.rsrc" write-out
  500. ;
  501.